home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 031-040 / amok38 / coco / demo / cocosynf < prev    next >
Encoding:
Modula Implementation  |  1993-11-04  |  15.2 KB  |  467 lines
  1. (* cocosyn  General table driven syntax analyzer           Re
  2.    =======  ====================================           Moe 21.12.83
  3. 01 (21.12.83) First version (rewritten from PL/M)
  4. 02 (28.02.84) New interface for input and errors
  5. 03 (02.04.84) Error in EOL-processing corrected
  6. 04 (08.05.84) New EOL-processing
  7. 05 (23.07.84) For G-Code
  8. 06 (30.08.84) Error recovery simplified
  9. 07 (05.04.85) New G-Code instruction EPSA (ANYA modified)
  10. 08 (07.11.86) ByteBlockIO added, ATARI file names          La   
  11. 09 (04.12.86) Alignment in Symbolnode corrected            La       
  12. ----------------------------------------------------------------------*)
  13. IMPLEMENTATION MODULE -->modulename;
  14.  
  15. FROM FileIO        IMPORT con, WriteCard, WriteLn, WriteString;
  16. FROM FileSystem    IMPORT Close, File, Lookup, Response;
  17. FROM SYSTEM        IMPORT WORD, BITSET;                  (*2.12.,I,Dob*)
  18. FROM Storage       IMPORT ALLOCATE, DEALLOCATE;          (*2.12.,D,Dob*)
  19. FROM ByteBlockIO   IMPORT ReadByteBlock;
  20.  
  21. FROM -->semantic analyzer IMPORT Semant;
  22. FROM -->input module      IMPORT -->input procedure;
  23. FROM -->error module      IMPORT -->error procedure, Errorptr;
  24.  
  25. -->declarations
  26.  
  27. CONST        (*opcodes for G-code-instructions*)         (*2.12.,I,Dob*)
  28.   t    = 0; ta   = 1; nt   = 2; nta  = 3;
  29.   nts  = 4; ntas = 5; any  = 6; anya = 7;
  30.   eps  = 8; epsa = 9; jmp  =10; ret  =11;
  31.  
  32. TYPE
  33.   Attributenumbers = ARRAY[0..maxp] OF CARDINAL;
  34.   Instrtype        = [0..255];                           (*2.12.,C,Dob*)
  35.   Namepointers     = ARRAY[0..maxnamep] OF CARDINAL;
  36.   Namelist         = ARRAY[1..maxname] OF CHAR;
  37.   Pragma           = RECORD    (*semantics for a pragma*)
  38.     sem2,sem3: CARDINAL;
  39.     END;
  40.   Pragmalist       = ARRAY[maxt..maxp] OF Pragma;
  41.   Symbolset        = ARRAY[0..maxt DIV 16] OF BITSET;
  42.                                (*set of terminals*)
  43.   Symbolnode       = RECORD    (*symbol information (only for nt)*)
  44.     startpc: CARDINAL;         (*start node of rule for nt*)
  45.     dummy,                     (*for correct alignment*)     (*4.12.86 La*)
  46.     del:     BOOLEAN;          (*TRUE, if nt is deletable*)
  47.     first:   Symbolset;        (*terminals causing to analyze this nt*)
  48.     END;
  49.   Symbollist       = ARRAY[maxp+1..maxs] OF Symbolnode;
  50.  
  51. VAR
  52.   anyset:    ARRAY[1..maxany] OF Symbolset;
  53.   code:      ARRAY[1..maxcode] OF CHAR; (*G-code area*)
  54.   correct1:   BOOLEAN;          (*error indicator*)
  55.   epsset:    ARRAY[1..maxeps] OF Symbolset;
  56.   name:      Namelist;         (*symbol names*)
  57.   namep:     Namepointers;     (*pointers to symbol names*)
  58.   nra:       Attributenumbers; (*nr.of attributes for t,pr-symbols*)
  59.   ntsymbols: Symbollist;       (*nonterminals information*)
  60.   pc:        CARDINAL;         (*program counter*)
  61.   ps:        Pragmalist;       (*semantics for pragmas*)
  62.   lacts:     CARDINAL;         (*stack pointer*)
  63.   (*typ,at,col and line are declared in the definition module*)
  64.  
  65. PROCEDURE RestoreStack;FORWARD;
  66. PROCEDURE SaveStack;FORWARD;
  67. PROCEDURE StackElem(i:CARDINAL): CARDINAL;FORWARD;
  68.  
  69. (* Match     Check if sy is member of the specified set
  70. ---------------------------------------------------------------------*)
  71. PROCEDURE Match(sy:CARDINAL; set:Symbolset): BOOLEAN;
  72. BEGIN RETURN (sy MOD 16) IN set[sy DIV 16]; END Match;
  73.  
  74.  
  75. (* Next      Get next byte from code area
  76. ---------------------------------------------------------------------*)
  77. PROCEDURE Next(): CARDINAL;
  78. BEGIN INC(pc); RETURN ORD(code[pc-1]); END Next;
  79.  
  80.  
  81. (* Next2     Get next word from code area
  82. ---------------------------------------------------------------------*)
  83. PROCEDURE Next2(): CARDINAL;
  84. BEGIN
  85.   INC(pc,2); RETURN 256*ORD(code[pc-2]) + ORD(code[pc-1]);
  86.   END Next2;
  87.  
  88.  
  89. (* NextSym    Get next symbol
  90. -----------------------------------------------------------------------*)
  91. PROCEDURE NextSym;
  92. VAR token,i: CARDINAL;
  93. BEGIN
  94.   REPEAT
  95.     -->input procedure(token);
  96.     typ:=token DIV 256; col:=token MOD 256;
  97.     IF printinput THEN
  98.       WriteString(con,"$(in:"); WriteCard(con,typ,3);
  99.       WriteString(con,") ");
  100.       IF printnodes THEN
  101.         WriteCard(con,lacts,3); WriteString(con,"| ");
  102.         END;
  103.       END;
  104.     FOR i:=1 TO nra[typ] DO -->input procedure(at[i]); END;
  105.     IF typ=eolsy THEN INC(line); END;
  106.     IF typ>maxt THEN
  107.       IF correct1 AND (ps[typ].sem2<>0) THEN Semant(ps[typ].sem2); END;
  108.       IF correct1 AND (ps[typ].sem3<>0) THEN Semant(ps[typ].sem3); END;
  109.       END;
  110.     UNTIL (typ<=maxt) OR (typ=eofsy);
  111.   END NextSym;
  112.  
  113.  
  114.  
  115. MODULE ERRORS;   (* Procedures for recovery after syntax errors
  116. =====================================================================*)
  117. FROM SYNTAXSTACK IMPORT StackElem;
  118. IMPORT                                                   (*2.12.,C,Dob*)
  119.   t, ta, nt, nta, nts, ntas, any, anya, eps, epsa, jmp, ret, Instrtype,
  120.   code, col, con, correct1, errmsg, Errorptr, line, Match, maxt,
  121.   name, namep, NextSym, ntsymbols, printnodes, RestoreStack, SaveStack,
  122.   Symbolset, -->error procedure, typ, WriteCard, WriteLn, WriteString,
  123.   ALLOCATE, DEALLOCATE, lacts;
  124. EXPORT errdist, Error;
  125. CONST errdistmin = 2;   (*min.distance between two errors*)
  126. VAR
  127.   errdist:  CARDINAL;                      (*current error distance*)
  128.   newlacts: ARRAY [0..maxt] OF CARDINAL;   (*new stack length*)
  129.   newpc:    ARRAY [0..maxt] OF CARDINAL;   (*pc after recovery*)
  130.  
  131.  
  132. PROCEDURE GetSymInstr(pc:CARDINAL; VAR opcode:Instrtype; (*2.12.,C,Dob*)
  133.                       VAR sy,nextpc,altpc: CARDINAL);FORWARD;
  134. PROCEDURE Triple(altroot:CARDINAL);FORWARD;
  135.  
  136. (* AdjustPc    Adjust pc to next symbol instruction
  137. ---------------------------------------------------------------------*)
  138. PROCEDURE AdjustPc(VAR pc:CARDINAL);
  139. BEGIN
  140.   IF pc=0 THEN RETURN; END;
  141.   LOOP
  142.     CASE ORD(code[pc]) OF                                (*2.12.,C,Dob*)
  143.       t,ta,nt,nta,nts,ntas,any,anya,eps,epsa: EXIT;
  144.     | jmp: pc:=256*ORD(code[pc+1])+ORD(code[pc+2]);
  145.     | ret: pc:=0; EXIT;
  146.       ELSE INC(pc); (*sem*)
  147.       END;
  148.     END;
  149.   END AdjustPc;
  150.  
  151.  
  152. (* Error       Report syntax error
  153. ---------------------------------------------------------------------*)
  154. PROCEDURE Error(VAR pc,altroot:CARDINAL);
  155. VAR
  156.   e,e1,h: Errorptr;
  157.   i,j: CARDINAL;
  158.   opcode: Instrtype;                                     (*2.12.,C,Dob*)
  159.   sy,nextpc,altpc,pc1: CARDINAL;
  160.  
  161.     PROCEDURE GiveName(q:Errorptr; sy:CARDINAL);
  162.     VAR p,j: CARDINAL;
  163.     BEGIN
  164.       p:=namep[sy]; j:=0;
  165.       WHILE (j<25) AND (name[p+j]<>0C) DO
  166.         INC(j); q^.txt[j]:=name[p+j-1];
  167.         END;
  168.       q^.l:=j;
  169.       END GiveName;
  170.  
  171. BEGIN (*Error*)
  172.   correct1:=FALSE;
  173.   IF errdist >= errdistmin
  174.     THEN
  175.       IF errmsg
  176.         THEN
  177.           ALLOCATE(h, SIZE(h^)); GiveName(h,typ);    (*pass near-symbol*)
  178.           h^.next:=NIL; e1:=h;
  179.           pc1:=altroot;  AdjustPc(pc1);
  180.           WHILE pc1>0 DO
  181.             GetSymInstr(pc1,opcode,sy,nextpc,altpc);
  182.             IF opcode<any THEN   (*t,nt,nts,ta,nta,ntas*)
  183.               ALLOCATE(e, SIZE(e^)); GiveName(e,sy);   (*pass expected symbol*)
  184.               e1^.next:=e; e1:=e; e^.next:=NIL;
  185.               END;
  186.             pc1:=altpc;
  187.             END; (*WHILE*)
  188.         ELSE h:=NIL
  189.         END; (*IF errmsg*)
  190.       -->error procedure(h,line,col);
  191.       Triple(altroot); SaveStack;
  192.       IF printnodes THEN
  193.         WriteString(con,"$   typ    newpc  newlacts$");
  194.         FOR i:=0 TO maxt DO
  195.           IF newpc[i]<>0 THEN
  196.             WriteCard(con,i,5); WriteCard(con,newpc[i],10);
  197.             WriteCard(con,newlacts[i],10); WriteLn(con);
  198.             END; (*IF*)
  199.           END; (*FOR*)
  200.         END; (*IF*)
  201.     ELSE RestoreStack;
  202.     END;
  203.   WHILE newpc[typ]=0 DO
  204.     IF printnodes THEN
  205.       WriteString(con,"$(skip:"); WriteCard(con,typ,0);
  206.       WriteString(con,") ");
  207.       END;
  208.     NextSym;
  209.     END;
  210.   pc:=newpc[typ]; altroot:=pc; lacts:=newlacts[typ]; errdist:=0;
  211.   END Error;
  212.  
  213.  
  214. (* Fill        Fill triple list with alt-chain starting at pc
  215. ----------------------------------------------------------------------*)
  216. PROCEDURE Fill(pc,lacts:CARDINAL);
  217. VAR
  218.   i,sy,nextpc,altpc: CARDINAL;
  219.   s: Symbolset;
  220.   opcode: Instrtype;                                     (*2.12.,C,Dob*)
  221. BEGIN
  222.   AdjustPc(pc);
  223.   WHILE pc<>0 DO
  224.     GetSymInstr(pc,opcode,sy,nextpc,altpc);
  225.     CASE opcode OF
  226.       t,ta:
  227.         newpc[sy]:=pc; newlacts[sy]:=lacts;
  228.     | nt,nta,nts,ntas:
  229.         s:=ntsymbols[sy].first;
  230.         FOR i:=0 TO maxt DO
  231.           IF Match(i,s) THEN newpc[i]:=pc; newlacts[i]:=lacts; END;
  232.           END;
  233.         IF ntsymbols[sy].del THEN Fill(nextpc,lacts); END;
  234.     | eps,epsa:
  235.         Fill(nextpc,lacts);
  236.       ELSE (*any,anya: nothing*)
  237.       END; (*CASE*)
  238.     pc:=altpc;
  239.     END; (*WHILE*)
  240.   END Fill;
  241.  
  242.  
  243. (* FillSucc      Fill triple list with succ. of alt-chain at pc
  244. ---------------------------------------------------------------------*)
  245. PROCEDURE FillSucc(pc,lacts:CARDINAL);
  246. VAR
  247.   opcode: Instrtype;                                     (*2.12.,C,Dob*)
  248.   sy,nextpc,altpc: CARDINAL;
  249. BEGIN
  250.   AdjustPc(pc);
  251.   WHILE pc>0 DO      (*fill with successors of alternative-starts*)
  252.     GetSymInstr(pc,opcode,sy,nextpc,altpc);
  253.     IF nextpc>0 THEN Fill(nextpc,lacts); END;
  254.     pc:=altpc;
  255.     END; (*WHILE*)
  256.   END FillSucc;
  257.  
  258.  
  259. (* GetSymInstr  Get G-code instruction at address pc
  260. ---------------------------------------------------------------------*)
  261. PROCEDURE GetSymInstr(pc:CARDINAL; VAR opcode:Instrtype; (*2.12.,C,Dob*)
  262.                       VAR sy,nextpc,altpc: CARDINAL);
  263. BEGIN (*assert: pc points to a symbol instruction (not ANY,RET,JMP,SEM)*)
  264.   opcode:=ORD(code[pc]);                                 (*2.12.,C,Dob*)
  265.   IF opcode IN {t,ta,nt,nta,nts,ntas,anya,eps,epsa}
  266.     THEN sy:=ORD(code[pc+1]);
  267.     ELSE sy:=0;
  268.     END;
  269.   CASE opcode OF
  270.     t,nt,eps:
  271.           nextpc:=pc+2;  altpc:=0;
  272.   | ta,nta,anya,epsa:
  273.           nextpc:=pc+4;  altpc:=256*ORD(code[pc+2])+ORD(code[pc+3]);
  274.   | nts:  nextpc:=pc+3;  altpc:=0;
  275.   | ntas: nextpc:=pc+5;  altpc:=256*ORD(code[pc+2])+ORD(code[pc+3]);
  276.   | any:  nextpc:=pc+1;  altpc:=0;
  277.     END; (*CASE*)
  278.   AdjustPc(nextpc); AdjustPc(altpc);
  279.   (*assert: nextpc,altpc point to symbol instructions or are zero*)
  280.   END GetSymInstr;
  281.  
  282.  
  283. (* Triple        Fill triple list
  284. ---------------------------------------------------------------------*)
  285. PROCEDURE Triple(altroot:CARDINAL);
  286. VAR i: CARDINAL;
  287. BEGIN
  288.   FOR i:=0 TO maxt DO              (*clear triple list*)
  289.     newpc[i]:=0; newlacts[i]:=0;
  290.     END;
  291.   FOR i:=1 TO lacts DO             (*fill with succ.of stacked nt's*)
  292.     (*s[1] contains successor at level 0*)
  293.     FillSucc(StackElem(i),i-1);
  294.     Fill(StackElem(i),i-1);
  295.     END;
  296.   FillSucc(altroot,lacts);         (*fill with succ.of alt-chain*)
  297.   Fill(altroot,lacts);             (*fill with current alt-chain*)
  298.   END Triple;
  299.  
  300. BEGIN  (*ERRORS*)
  301.   errdist:=100;
  302.   END ERRORS;
  303.  
  304.  
  305.  
  306. MODULE SYNTAXSTACK;  (* stack for currently parsed nonterminals
  307. =====================================================================*)
  308. IMPORT con, printnodes, WriteString, lacts;
  309. EXPORT Push, Pop, SSRestoreStack, SSSaveStack, SSStackElem;
  310. CONST  lmaxs = 50;                         (*max.stack length*)
  311. TYPE   Stack = ARRAY[1..lmaxs] OF CARDINAL;
  312. VAR    s,olds: Stack;
  313.  
  314. PROCEDURE Pop(VAR loc: CARDINAL);
  315. BEGIN
  316.   IF lacts>0
  317.     THEN loc:=s[lacts]; DEC(lacts);
  318.     ELSE WriteString(con,"--- Parser stack underflow.$"); HALT;
  319.     END;
  320.   IF printnodes THEN WriteString(con,"  pop"); END;
  321.   END Pop;
  322.  
  323. PROCEDURE Push(loc: CARDINAL);
  324. BEGIN
  325.   IF lacts<lmaxs
  326.     THEN INC(lacts); s[lacts]:=loc;
  327.     ELSE WriteString(con,"--- Parser stack overflow.$"); HALT;
  328.     END;
  329.   IF printnodes THEN WriteString(con," push"); END;
  330.   END Push;
  331.  
  332. PROCEDURE SSRestoreStack;
  333. BEGIN s:=olds; END SSRestoreStack;
  334.  
  335. PROCEDURE SSSaveStack;
  336. BEGIN olds:=s; END SSSaveStack;
  337.  
  338. PROCEDURE SSStackElem(i:CARDINAL): CARDINAL;
  339. BEGIN RETURN s[i]; END SSStackElem;
  340.  
  341. BEGIN
  342.   lacts:=0;
  343.   END SYNTAXSTACK;
  344.  
  345. PROCEDURE StackElem(i:CARDINAL): CARDINAL;
  346. BEGIN
  347.   RETURN SSStackElem(i);
  348. END StackElem;  
  349.  
  350. PROCEDURE RestoreStack;
  351. BEGIN SSRestoreStack; END RestoreStack;
  352.  
  353. PROCEDURE SaveStack;
  354. BEGIN SSSaveStack; END SaveStack;
  355.  
  356.  
  357. (* Parse         Proper syntax analyzer
  358. ---------------------------------------------------------------------*)
  359. PROCEDURE Parse(VAR correct:BOOLEAN);
  360. VAR
  361.   altroot: CARDINAL;     (*root of current alternative chain*)
  362.   checksum:CARDINAL;     (*table check sum*)
  363.   dummy:   CARDINAL;
  364.   mustread:BOOLEAN;      (*TRUE if next symbol must be read*)
  365.   opcode:  Instrtype;    (*instruction code*)            (*2.12.,C,Dob*)
  366.   header:  ARRAY[1..8] OF CARDINAL;
  367.   running: BOOLEAN;      (*interpreter state*)
  368.   sy:      CARDINAL;
  369.   tab:     File;         (*table file*)
  370.  
  371. BEGIN
  372.   Lookup(tab,tabfile,1024,FALSE);
  373.   IF tab.res<>done THEN
  374.     WriteString(con,"--- Parser tables not found.$"); HALT;
  375.     END;
  376.   ReadByteBlock(tab,header);  (*not used*)
  377.   ReadByteBlock(tab,code);
  378.   ReadByteBlock(tab,ntsymbols);
  379.   ReadByteBlock(tab,epsset);
  380.   ReadByteBlock(tab,anyset);
  381.   ReadByteBlock(tab,nra);
  382.   ReadByteBlock(tab,ps);
  383.   IF errmsg THEN
  384.     ReadByteBlock(tab,namep);
  385.     ReadByteBlock(tab,name);
  386.     END;
  387.   ReadByteBlock(tab,checksum);
  388.   IF check<>checksum THEN
  389.     WriteCard(con, check, 5);
  390.     WriteCard(con, checksum, 5);
  391.     WriteString(con,"--- Old parser version. Recompile it.$"); 
  392.     HALT;
  393.     END;
  394.   Close(tab);
  395.  
  396.   pc:=startpc; altroot:=pc;
  397.   line:=1; col:=1;
  398.   correct1:=TRUE; mustread:=TRUE; running:=TRUE;
  399.  
  400.   WHILE running DO
  401.     opcode:=Next();                                      (*2.12.,C,Dob*)
  402.     IF mustread AND (opcode<=epsa) THEN                  (*2.12.,C,Dob*)
  403.       NextSym; mustread:=FALSE; INC(errdist); altroot:=pc-1;
  404.       END;
  405.     IF printnodes THEN WriteCard(con,pc-1,5); END;
  406.     CASE opcode OF
  407.       t:
  408.         IF typ=Next()
  409.           THEN IF typ=eofsy                    (*t recognized*)
  410.             THEN running:=FALSE;
  411.             ELSE mustread:=TRUE;
  412.             END;
  413.           ELSE Error(pc,altroot);
  414.           END;
  415.     | ta:
  416.         IF typ=Next()
  417.           THEN dummy:=Next2(); mustread:=TRUE; (*t recognized*)
  418.           ELSE pc:=Next2();                    (*try alternative*)
  419.           END;
  420.     | nt,nts:
  421.         sy:=Next();
  422.         IF Match(typ,ntsymbols[sy].first) OR ntsymbols[sy].del
  423.           THEN                                 (*right nt, parse it*)
  424.             IF opcode=nts THEN Semant(Next()); END;
  425.             Push(pc); pc:=ntsymbols[sy].startpc;
  426.             altroot:=pc;
  427.           ELSE Error(pc,altroot);
  428.           END;
  429.     | nta,ntas:
  430.         sy:=Next();
  431.         IF Match(typ,ntsymbols[sy].first)
  432.           THEN                                 (*right nt, parse it*)
  433.             dummy:=Next2();
  434.             IF opcode=ntas THEN Semant(Next()); END;
  435.             Push(pc); pc:=ntsymbols[sy].startpc;
  436.             altroot:=pc;
  437.           ELSE pc:=Next2();                    (*try alternative*)
  438.           END;
  439.     | any:  mustread:=TRUE;                    (*any recognized*)
  440.     | anya:
  441.         IF Match(typ,anyset[Next()])
  442.           THEN dummy:=Next2(); mustread:=TRUE; (*any recognized*)
  443.           ELSE pc:=Next2();
  444.           END;
  445.     | eps:
  446.         IF NOT Match(typ,epsset[Next()]) THEN
  447.           Error(pc,altroot);
  448.           END;
  449.     | epsa:
  450.         IF Match(typ,epsset[Next()])
  451.           THEN dummy:=Next2();                 (*eps recognized*)
  452.           ELSE pc:=Next2();
  453.           END;
  454.     | jmp:  pc:=Next2();                       (*goto successor*)
  455.     | ret:  Pop(pc); altroot:=pc;              (*end of nt*)
  456.       ELSE (*sem*)
  457.         IF correct1 THEN Semant(opcode); END;             (*2.12.,C,Dob*)
  458.       END; (*CASE*)
  459.     END; (*WHILE running*)
  460.   correct:=correct1;
  461.   END Parse;
  462.  
  463. BEGIN
  464.   printinput:=FALSE;
  465.   printnodes:=FALSE;
  466.   END -->modulename.
  467.